Developer CD Series 1992 June: ROMin Holiday/ADC Developer CD (1992-06) (''ROMin Holiday'')_iso/Developer Connection - 06-1992.iso/Development Platforms/HyperCard Related/XCMDs & XFCNs/StackToPICSFile 1.1/PICSFileRoutines.p

Text File | 1991-04-05 | 5.2 KB | 225 lines | [TEXT/MPS ]

{$R-}
{$S PICSFileRoutines }

{
    PICSFileRoutines —— Pascal routines that can be used to create a PICS file

    These routines were initially written to support the development of the
    Hypercard XFCN StackToPICSFile, but could be of general utility for any program
    that wishes to create PICS files.

    All of the routines return a boolean indicating success.  If the return
    value is false, then an explanatory message will have been placed into the
    VAR parameter ErrorMessage.

}

UNIT PICSFileRoutines;

INTERFACE

USES
        Resources, Packages,
        OSIntf,  QuickDraw;

TYPE

FrameProcPtr = ProcPtr; { FUNCTION FrameProcPtr(CardNum: Integer;
                                                VAR theImage: PicHandle;
                                                VAR ErrorMessage: Str255): Boolean; }


FUNCTION StartMakingPICSFile(FileName: Str255;
                                CreatorType: OSType;
                                VAR resRefNum: Integer;
                                VAR ErrorMessage: Str255): Boolean;

FUNCTION AddFramesToPICSFile(resRefNum: Integer;
                                NumFrames: Integer;
                                {FrameProcPtr}
                                FUNCTION FrameProc(CardNum: Integer;
                                                VAR theImage: PicHandle;
                                                VAR ErrorMessage: Str255): Boolean;
                                VAR ErrorMessage: Str255): Boolean;

FUNCTION FinishMakingPICSFile(VAR resRefNum: Integer; VAR ErrorMessage: Str255): Boolean;


IMPLEMENTATION

CONST

PICSResourceBase =         128;    {* First resource ID in a PICS file *}

FUNCTION AddPICTToPICSFile(ThePict: PicHandle; resourceNum: Integer;
            resRefNum: Integer; VAR ErrorMessage: Str255): Boolean;
VAR
    Err:                    Integer;
    DebugString:            Str255;
BEGIN
    AddPICTToPICSFile := FALSE;

    UseResFile(resRefNum);
    Err := ResError;
    IF (Err <> noErr) THEN
    BEGIN
        ErrorMessage := 'Couldn’t start using the specified resource file';
        Exit(AddPICTToPICSFile);
    END;

    AddResource(Handle(ThePict), 'PICT', resourceNum, 'Frame of PICS Sequence');
    Err := ResError;
    IF (Err <> noErr) THEN
    BEGIN
        NumToString(Err, DebugString);
        ErrorMessage := concat('Couldn’t add PICT resource to resource file: ', DebugString);
        Exit(AddPICTToPICSFile);
    END;

    UpdateResFile(resRefNum);
    Err := ResError;
    IF (Err <> noErr) THEN
    BEGIN
        ErrorMessage := 'Couldn’t update resource file after adding resource';
        Exit(AddPICTToPICSFile);
    END;


    {* SetResAttrs(Handle(ThePict), resPurgeable); *}

    {* We detach the handle so that it does not continue to be a resource
        handle.  It wasn’t one on the way in; we don’t want it to be one on
        the way out.
        *}
    DetachResource(Handle(ThePict));

    AddPICTToPICSFile := TRUE;
END;

FUNCTION StartMakingPICSFile(FileName: Str255;
                                CreatorType: OSType;
                                VAR resRefNum: Integer;
                                VAR ErrorMessage: Str255): Boolean;
VAR
    Err:            Integer;
    info:            FInfo;

BEGIN
    StartMakingPICSFile := FALSE;

    CreateResFile(FileName);
    IF (ResError <> NoErr)  THEN
    BEGIN
        ErrorMessage := concat('Couldn’t create file: ', FileName, '.  It may already exist');
        Exit(StartMakingPICSFile);
    END;

    resRefNum := OpenResFile(FileName);
    IF (ResError <> NoErr) THEN
    BEGIN
        ErrorMessage := concat('Created a PICS file, but then couldn’t open it: ', FileName);
        Exit(StartMakingPICSFile);
    END;

    Err := GetFInfo(FileName, 0, info);
    IF (Err <> NoErr) THEN
    BEGIN
        CloseResFile(resRefNum);
        ErrorMessage := concat('Could not get file info for file: ', FileName);
        Exit(StartMakingPICSFile);
    END;

    info.fdType := 'PICS';
    info.fdCreator := CreatorType;

    Err := SetFInfo(FileName, 0, info);
    IF (Err <> NoErr) THEN
    BEGIN
        CloseResFile(resRefNum);
        ErrorMessage := concat('Could not set file info for file: ', FileName);
        Exit(StartMakingPICSFile);
    END;

    StartMakingPICSFile := TRUE;

END;

FUNCTION AddFramesToPICSFile(resRefNum: Integer;
                                NumFrames: Integer;
                                FUNCTION FrameProc(CardNum: Integer;
                                                VAR theImage: PicHandle;
                                                VAR ErrorMessage: Str255): Boolean;
                                VAR ErrorMessage: Str255): Boolean;
VAR
    FrameNum:             Integer;
    theFrame:            PicHandle;
    Success:            Boolean;
    resourceNum:        Integer;

BEGIN
    AddFramesToPICSFile := FALSE;
    Success := TRUE;

    FOR FrameNum := 1 to NumFrames DO
    BEGIN

        theFrame := PicHandle(NewHandle(0));
        IF (theFrame = NIL) THEN
        BEGIN
            Success := FALSE;
            ErrorMessage := 'Couldn’t allocate zero-size handle';
            Leave;
        END;

        IF (FrameProc(FrameNum, theFrame, ErrorMessage) = FALSE) THEN
        BEGIN
            Success := FALSE;
            {* ErrorMessage was set by calling FrameProc *}
            DisposHandle(Handle(theFrame));
            Leave;
        END;

        resourceNum := PICSResourceBase + FrameNum - 1;
        Success := Success AND AddPICTToPICSFile(theFrame, resourceNum, resRefNum, ErrorMessage);
        IF (NOT Success) THEN
        BEGIN
            {* ErrorMessage was set by AddPICTToPICSFile *}
            DisposHandle(Handle(theFrame));
            Leave;
        END;

        DisposHandle(Handle(theFrame));

    END;

    AddFramesToPICSFile := Success;

    IF (NOT Success) THEN
    BEGIN
        {* ErrorMessage was set during the loop above. *}
        Exit(AddFramesToPICSFile);
    END;
END;

FUNCTION FinishMakingPICSFile(VAR resRefNum: Integer; VAR ErrorMessage: Str255): Boolean;
VAR
    Err:            Integer;
BEGIN
    FinishMakingPICSFile := FALSE;

    CloseResFile(resRefNum);
    Err := ResError;
    IF (Err <> NoErr) THEN
    BEGIN
        ErrorMessage := concat('Error closing file');
        Exit(FinishMakingPICSFile);
    END;

    FinishMakingPICSFile := TRUE;

END;

END. { PICSFileRoutines Unit }